home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / misc / warn-slow.lsp < prev   
Encoding:
Lisp/Scheme  |  1991-10-29  |  1.3 KB  |  50 lines
  1. ;; Warn of some slow calls.
  2. (in-package 'compiler)
  3.  
  4. ;; slow if the result type is type T
  5. (dolist (v '(+ * / mod - float 1- 1+))
  6.   (setf (get v 'slow-test)
  7.     #'(lambda (name x) (or (null x)  (eql (cadar x) t)))))
  8.  
  9. ;; slow if the first arg is type T
  10. (dolist (v '(aref si::aset < <= > >=))
  11.   (setf (get v 'slow-test)
  12.     #'(lambda (name x) (or (null x) (eql (caar x) t)))))
  13.  
  14. (dolist (v '(typep))
  15.   (setf (get v 'slow-test)
  16.     #'(lambda (name x) (null x))))
  17.  
  18.  
  19. ;; turn the compiler expressions back into something vaguely
  20. ;; readable.
  21. (defun lispify (x)
  22.    (let ((tem  (car x)))
  23.      (cond ((equal tem 'var)
  24.         (var-name (car (third x))))
  25.        ((eq tem 'call-global)
  26.         (cons (third x)
  27.           (mapcar 'lispify (fourth x))))
  28.        ((eq tem 'fixnum-value)
  29.         (third x))
  30.        ((eq tem 'location)
  31.         (lispify (third x)))
  32.        (t x))))
  33.  
  34. (eval-when (load eval)
  35.  (trace (get-inline-info :entry nil
  36.         :entrycond nil
  37.         :exitcond
  38.         (and (not (equal (car values) nil))
  39.          (let ((s (get (car si::arglist) 'slow-test)))
  40.            (and s (funcall s (car si::arglist) (car values))))
  41.          (progn
  42.            (cmpwarn "Slow code: ~a: "
  43.           (cons (car si::arglist)
  44.             (mapcar 'lispify (second si::arglist))))
  45.            (format t " ~a --> ~a~%"
  46.                (mapcar #'(lambda (form) (info-type (cadr form)))
  47.                    (second si::arglist))
  48.                (third si::arglist)))
  49.          nil)))
  50. )